I

# carga del paquete {lattice}
suppressWarnings(suppressMessages(library(lattice)))
# carga de los datos
housing <- read.csv("data/housing.csv", head = FALSE)
names(housing) <- c("CRIM", "ZN", "INDUS", "NOX", "RM",
                    "AGE", "DIS", "RAD", "TAX", "PTRATIO")

I.1

Se explora la relación entre las tasa de criminalidad CRIM, las tasa de impuestos a la propiedad TAX y la distancia a los centros de empleo DIS.

Se utiliza la variable TAX para crear la segmentación en grupos y crear el xyplot():

housing$TAX_GRP <- equal.count(housing$TAX, number = 4, overlap = 0)
xyplot(DIS ~ CRIM | TAX_GRP, data = housing, pch = 19, 
       groups = TAX_GRP)

Se puede apreciar que en los grupos con menores tasas de impuesto la relación entre criminalidad y distancia es muy baja. En las zonas con mayores tasas impositivas hay una relación inversa debil entre la tasas de criminalidad y la distancia a los centros de empleo.

II.2

Se agrega una segunda variable cualitativa descrita por la accesibilidad a autopistas RAD:

housing$RAD_GRP <- equal.count(housing$RAD, number = 3, overlap = 0)
xyplot(DIS ~ CRIM | TAX_GRP * RAD_GRP, 
       data = housing, pch = 19, 
       groups = TAX_GRP)

En general no se aprecia ningún aporte significativo por la adición de la nueva dimensión al gráfico; se puede apreciar solamente que los mismos comentarios realizados en el inciso anterior para las zonas con alta tasa de impuestos se puede realizar para las zonas con alto índice de accesibilidad a pistas.

Se puede corroborar que efectivamente mucha de la información contenida por la variable TAX se puede extraer de la variable RAD a partir de la alta correlación entre ambas variables:

cor(housing[,c("RAD", "TAX")])
##           RAD       TAX
## RAD 1.0000000 0.9102282
## TAX 0.9102282 1.0000000

I.3

Ahora se muestra la distribución de edad AGE segmentando por la tasa de impuestos.

densityplot( ~ AGE | TAX_GRP, data = housing)

Note que la distribución de antigüedad de los inmuebles es bastante pareja para las zonas con tasas impositivas menores, y en zonas con tasas impositivas mayores hay mucho peso para antigüedades mayores.

II.1

El dataset consiste en información nutricional del menú de McDonalds:

mcmenu <- data.frame(data.table::fread("data/menu.csv"))

Continene información de calorías, grasas, carbohidratos, proteinas y vitaminas, entre otros:

summary(mcmenu)
##    Category             Item           Serving.Size          Calories     
##  Length:260         Length:260         Length:260         Min.   :   0.0  
##  Class :character   Class :character   Class :character   1st Qu.: 210.0  
##  Mode  :character   Mode  :character   Mode  :character   Median : 340.0  
##                                                           Mean   : 368.3  
##                                                           3rd Qu.: 500.0  
##                                                           Max.   :1880.0  
##  Calories.from.Fat   Total.Fat       Total.Fat....Daily.Value.
##  Min.   :   0.0    Min.   :  0.000   Min.   :  0.00           
##  1st Qu.:  20.0    1st Qu.:  2.375   1st Qu.:  3.75           
##  Median : 100.0    Median : 11.000   Median : 17.00           
##  Mean   : 127.1    Mean   : 14.165   Mean   : 21.82           
##  3rd Qu.: 200.0    3rd Qu.: 22.250   3rd Qu.: 35.00           
##  Max.   :1060.0    Max.   :118.000   Max.   :182.00           
##  Saturated.Fat    Saturated.Fat....Daily.Value.   Trans.Fat     
##  Min.   : 0.000   Min.   :  0.00                Min.   :0.0000  
##  1st Qu.: 1.000   1st Qu.:  4.75                1st Qu.:0.0000  
##  Median : 5.000   Median : 24.00                Median :0.0000  
##  Mean   : 6.008   Mean   : 29.97                Mean   :0.2038  
##  3rd Qu.:10.000   3rd Qu.: 48.00                3rd Qu.:0.0000  
##  Max.   :20.000   Max.   :102.00                Max.   :2.5000  
##   Cholesterol     Cholesterol....Daily.Value.     Sodium      
##  Min.   :  0.00   Min.   :  0.00              Min.   :   0.0  
##  1st Qu.:  5.00   1st Qu.:  2.00              1st Qu.: 107.5  
##  Median : 35.00   Median : 11.00              Median : 190.0  
##  Mean   : 54.94   Mean   : 18.39              Mean   : 495.8  
##  3rd Qu.: 65.00   3rd Qu.: 21.25              3rd Qu.: 865.0  
##  Max.   :575.00   Max.   :192.00              Max.   :3600.0  
##  Sodium....Daily.Value. Carbohydrates    Carbohydrates....Daily.Value.
##  Min.   :  0.00         Min.   :  0.00   Min.   : 0.00                
##  1st Qu.:  4.75         1st Qu.: 30.00   1st Qu.:10.00                
##  Median :  8.00         Median : 44.00   Median :15.00                
##  Mean   : 20.68         Mean   : 47.35   Mean   :15.78                
##  3rd Qu.: 36.25         3rd Qu.: 60.00   3rd Qu.:20.00                
##  Max.   :150.00         Max.   :141.00   Max.   :47.00                
##  Dietary.Fiber   Dietary.Fiber....Daily.Value.     Sugars      
##  Min.   :0.000   Min.   : 0.000                Min.   :  0.00  
##  1st Qu.:0.000   1st Qu.: 0.000                1st Qu.:  5.75  
##  Median :1.000   Median : 5.000                Median : 17.50  
##  Mean   :1.631   Mean   : 6.531                Mean   : 29.42  
##  3rd Qu.:3.000   3rd Qu.:10.000                3rd Qu.: 48.00  
##  Max.   :7.000   Max.   :28.000                Max.   :128.00  
##     Protein      Vitamin.A....Daily.Value. Vitamin.C....Daily.Value.
##  Min.   : 0.00   Min.   :  0.00            Min.   :  0.000          
##  1st Qu.: 4.00   1st Qu.:  2.00            1st Qu.:  0.000          
##  Median :12.00   Median :  8.00            Median :  0.000          
##  Mean   :13.34   Mean   : 13.43            Mean   :  8.535          
##  3rd Qu.:19.00   3rd Qu.: 15.00            3rd Qu.:  4.000          
##  Max.   :87.00   Max.   :170.00            Max.   :240.000          
##  Calcium....Daily.Value. Iron....Daily.Value.
##  Min.   : 0.00           Min.   : 0.000      
##  1st Qu.: 6.00           1st Qu.: 0.000      
##  Median :20.00           Median : 4.000      
##  Mean   :20.97           Mean   : 7.735      
##  3rd Qu.:30.00           3rd Qu.:15.000      
##  Max.   :70.00           Max.   :40.000

II.2

suppressMessages(suppressWarnings(library(plotly)))
plot_ly(mcmenu, x = ~Calories, y = ~Protein, z = ~Sugars, 
        type = "scatter3d", mode="markers")

III. 1

# carga de la libreria {maps}
library(maps)
# lectura de los datos
WDS2014 <- data.frame(data.table::fread("data/WDS2014v3.csv"))

Se inicializa el objeto necesario para dibujar el mampa y se procede a la asignacion de los valores de interés a cada país:

# set up del mapa
x <- map(plot = FALSE)
x$measure <- array(NA,dim=length(x$names))
x$idx <- array(NA,dim=length(x$names))

# agregar datos para paises incluidos en el dataset
for(i in 1:length(x$names)) {
  idx <- grepl(x$names[i], WDS2014$Country.Name, 
               ignore.case = T)
  if (any(idx)) {
    x$idx[i] <- which(idx)[1]
    x$measure[i] <- WDS2014$ABS[x$idx[i]]
  }
}

# asignacion manual de valores para uk, usa, japon, y otros 
`%like%` <- function(x, pattern, ...) grepl(pattern, x, ignore.case = T, ...)
x$measure[x$names %like% "^USA"] <- WDS2014$ABS[WDS2014$Country.Name == "United States"]
x$measure[x$names %like% "^UK[^r]"] <- WDS2014$ABS[WDS2014$Country.Name == "United Kingdom"]
x$measure[x$names %like% "japan"] <- WDS2014$ABS[WDS2014$Country.Name == "Japan"]
x$measure[x$names %like% "south korea"] <- WDS2014$ABS[WDS2014$Country.Name == "Korea, Rep."]
x$measure[x$names %like% "north korea"] <- WDS2014$ABS[WDS2014$Country.Name %like% "Korea.*Dem.*People"]
x$names[x$names %like% "new zealand"] <- WDS2014$ABS[WDS2014$Country.Name == "New Zealand"]

Finalmente se especifican las opciones de color, partición de los grupos y graficación del mapa:

#Definición de color
library(RColorBrewer)
colors = brewer.pal(5,"GnBu")

#Vector de colores en función al valor de EVT. Se crean 5 grupos 
sd <- data.frame(col=colors, values <- seq(min(x$measure[!is.na(x$measure)]), max(x$measure[!is.na(x$measure)]) *1.0001,length.out=5))
#Vector de valores en blanco para los países que no se encuentren
sc<-array("#FFFFFF",dim=length(x$names))

#Asignar el color según el intervalo en el cual se encuentre el país
for (i in 1:length(x$measure))
  if(!is.na(x$measure[i]))
    sc[i]=as.character(sd$col[findInterval(x$measure[i],sd$values)])

#2-Layout para poner la leyenda a la derecha del mapa
layout(matrix(data=c(2,1), nrow=1, ncol=2), widths=c(8,1), heights=c(8,1))

# Escala de colores (leyenda)
breaks<-sd$values
par(mar = c(10,1,4,5),oma=c(0.2,0.2,0.2,0.2),mex=0.5)

#leyenda como imagen
image(x=1, y=0:length(breaks),z=t(matrix(breaks))*1.001,col=colors[1:length(breaks)-1],axes=FALSE, breaks=breaks, xlab="",ylab="",xaxt="n")

axis(side=4,at=0:(length(breaks)-1), labels = round(breaks), col="white", las=1)
#simular líneas separadoras
abline(h=c(1:length(breaks)),col="white",lwd=2,xpd=F)

#Mapa solo colores
map(col=sc,fill=TRUE,lty="blank")
#silueta
map(add=TRUE,col="gray",fill=FALSE)
title("Porcentaje de Area Forestal")

Se puede observar valores más altos en Sudamérica.

III.2

Se copia el código:

#Instalar y cargar el mapa
# install.packages("RgoogleMaps", dependencies = TRUE)
library(RgoogleMaps)
#Datos de capitales
datos <- read.csv(file="data/world_cities.csv", head=TRUE, sep=",", dec = ".")
capital <- datos[datos$city=="Ottawa",]
lat <- c(capital$lat -20,capital$lat+20) #Rango en y
lon <- c(capital$lng-20,capital$lng+20) #Rango en x
center = c(capital$lat, capital$lng) #Centro del gráfico
zoom <- 5 #zoom: 1 = Todo el globo,
#Mapa
terrmap <- GetMap(center=center, 
                  zoom=zoom, 
                  maptype= "roadmap" , 
                  destfile = "CA.png") #graficar mapa
PlotOnStaticMap(terrmap)
text(x=1, y= capital$lat, labels = "EVT:=82", cex = 0.8)

A partir de los datos cargados, se escogen las capitales de Norte América

# carga de dplyr
suppressMessages(suppressWarnings(library(dplyr)))

# filtrado de ciudades de interés
datos2 <- dplyr::filter(datos,
              grepl("mexico city|washington, d\\.c\\.|ottawa",
                    city, 
                    ignore.case = T))
# cálculo de latitudes/longitudes promedio para insumo de GetMap()
range1 <- datos2 %>% filter(iso3 %in% c("USA", "MEX", "CAN")) %>% 
  summarise(avg_lat = mean(lat), avg_lng = mean(lng))
center <- with(range1, c(avg_lat, avg_lng))

# extraccion de etiquetas
datos2 <- mutate(datos2,life_exp = c(WDS2014$EVT[WDS2014$Country.Name == "Canada"],
                              WDS2014$EVT[WDS2014$Country.Name == "Mexico"],
                              WDS2014$EVT[WDS2014$Country.Name == "United States"]))

# creacion del mapa
terrmap <- GetMap(center=center, 
                  zoom=4, 
                  maptype= "roadmap" , 
                  destfile = "CA.png") #graficar mapa

tmp <- PlotOnStaticMap(terrmap, destfile = "MyTile1.png",
                lat = datos2$lat,
                lon = datos2$lng,
                pch = 15, col = "red", add = FALSE)

PlotOnStaticMap(terrmap,
                lat = datos2$lat + 1,
                lon = datos2$lng + 5,
                cex = 0.7,
                FUN = pryr::partial(text, 
                                    labels = paste("EVT:=",format(datos2$life_exp))),
                add = TRUE)